home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / match.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  10.3 KB  |  313 lines  |  [TEXT/MPS ]
  1. (*  match.ml : expansion of pattern-matching as a cascade of tests. *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "globals";;
  6. #open "syntax";;
  7. #open "location";;
  8. #open "lambda";;
  9. #open "prim";;
  10. #open "instruct";;
  11.  
  12. (*  See Peyton-Jones, The Implementation of functional programming
  13.     languages, chapter 5. *)
  14.  
  15. (* A pattern-matching is represented as a disjunction of conjunctions:
  16.  
  17.       pat & pat & ... & pat  ->  action
  18.     | pat & pat & ... & pat  ->  action
  19.     | ...
  20.     | pat & pat & ... & pat  ->  action
  21.  
  22.       exp   exp   ...   exp
  23.  
  24.   A pattern "pat" applies to (i.e. must match) the expression below it. *)
  25.  
  26. type pattern_matching =
  27.   Matching of (pattern list * lambda) list * lambda list
  28. ;;
  29.  
  30. (* Simple pattern manipulations *)
  31.  
  32. let make_path n (path::pathl) =
  33.   let rec make i =
  34.     if i >= n then pathl else Lprim(Pfield i, [path]) :: make (i+1)
  35.   in
  36.     make 0
  37. ;;
  38.  
  39. let add_to_match (Matching(casel,pathl)) cas =
  40.   Matching(cas :: casel, pathl)
  41.  
  42. and make_constant_match = fun
  43.     (path :: pathl) cas -> Matching([cas], pathl)
  44.   | _ _ -> fatal_error "make_constant_match"
  45.  
  46. and make_tuple_match arity pathl =
  47.   Matching([], make_path arity pathl)
  48.  
  49. and make_construct_match cstr (path :: pathl as pathl0) cas =
  50.   match cstr.info.cs_kind with
  51.     Constr_constant ->
  52.       Matching([cas], pathl)
  53.   | Constr_superfluous n ->
  54.       Matching([cas], pathl0)
  55.   | _ ->
  56.       Matching([cas], Lprim(Pfield 0, [path]) :: pathl)
  57. ;;
  58.  
  59. (* Auxiliaries for factoring common tests *)
  60.  
  61. let add_to_division make_match divlist key cas =
  62.   try
  63.     let matchref = assoc key divlist in
  64.       matchref := add_to_match !matchref cas; divlist
  65.     with Not_found ->
  66.       (key, ref (make_match cas)) :: divlist
  67. ;;
  68.  
  69. (* To skip type constraints and aliases, and flatten "or" patterns. *)
  70.  
  71. let rec simpl_casel = function
  72.     (Pat(Zaliaspat(pat,v),_) :: patl, action) :: rest ->
  73.       simpl_casel ((pat::patl, action) :: rest)
  74.   | (Pat(Zconstraintpat(pat,ty),_) :: patl, action) :: rest ->
  75.       simpl_casel ((pat::patl, action) :: rest)
  76.   | (Pat(Zorpat(pat1, pat2),_) :: patl, action) :: rest ->
  77.       simpl_casel ((pat1::patl, action) :: (pat2::patl, action) :: rest)
  78.   | casel ->
  79.       casel
  80. ;;
  81.  
  82. (* Factoring pattern-matchings. *)
  83.  
  84. let divide_constant_matching (Matching(casel, pathl)) =
  85.   divide_rec casel where rec divide_rec casel =
  86.     match simpl_casel casel with
  87.       (Pat(Zconstantpat(cst),_) :: patl, action) :: rest ->
  88.         let (constant, others) = divide_rec rest in
  89.           add_to_division
  90.             (make_constant_match pathl) constant cst (patl, action),
  91.           others
  92.     | casel ->
  93.         [], Matching(casel, pathl)
  94. ;;
  95.  
  96. let divide_tuple_matching arity (Matching(casel, pathl)) =
  97.   divide_rec casel where rec divide_rec casel =
  98.     match simpl_casel casel with
  99.       (Pat(Ztuplepat(args), _) :: patl, action) :: rest ->
  100.         add_to_match (divide_rec rest) (args @ patl, action)
  101.     | (Pat((Zwildpat | Zvarpat _), _) :: patl, action) :: rest ->
  102.         let rec make_pats i =
  103.           if i >= arity
  104.           then []
  105.           else Pat(Zwildpat, no_location) :: make_pats (i+1) in
  106.         add_to_match (divide_rec rest) (make_pats 0 @ patl, action)
  107.     | [] ->
  108.         make_tuple_match arity pathl
  109.     | _ ->
  110.         fatal_error "divide_tuple_matching"
  111. ;;
  112.  
  113. let divide_construct_matching (Matching(casel, pathl)) =
  114.   divide_rec casel where rec divide_rec casel =
  115.     match simpl_casel casel with
  116.       (Pat(Zconstruct0pat(c), _) :: patl, action) :: rest ->
  117.         let (constrs, others) =
  118.           divide_rec rest in
  119.         add_to_division
  120.           (make_construct_match c pathl) constrs c.info.cs_tag (patl, action),
  121.         others
  122.     | (Pat(Zconstruct1pat(c,arg),_) :: patl, action) :: rest ->
  123.         let patl' =
  124.           match c.info.cs_kind with
  125.             Constr_constant -> patl
  126.           |          _      -> arg :: patl in
  127.         let (constrs, others) =
  128.           divide_rec rest in
  129.         add_to_division
  130.           (make_construct_match c pathl) constrs c.info.cs_tag (patl', action),
  131.         others
  132.     | casel ->
  133.         [], Matching(casel, pathl)
  134. ;;
  135.  
  136. let divide_var_matching (Matching(casel, (_ :: endpathl as pathl))) =
  137.   divide_rec casel where rec divide_rec casel =
  138.     match simpl_casel casel with
  139.       (Pat((Zwildpat | Zvarpat _),_) :: patl, action) :: rest ->
  140.         let vars, others = divide_rec rest in
  141.           add_to_match vars (patl, action),
  142.           others
  143.     | casel ->
  144.         Matching([], endpathl), Matching(casel, pathl)
  145. ;;
  146.  
  147. let divide_record_matching (Matching(casel, pathl)) =
  148.   let max_pos = ref 0 in
  149.   let rec max_size = function
  150.       Pat(Zaliaspat(pat,v),_) -> max_size pat
  151.     | Pat(Zconstraintpat(pat,ty),_) -> max_size pat
  152.     | Pat(Zorpat(pat1,pat2),_) -> max_size pat1; max_size pat2
  153.     | Pat(Zrecordpat pat_expr_list,_) ->
  154.         do_list
  155.           (fun (lbl,p) ->
  156.             if lbl.info.lbl_pos > !max_pos then
  157.               (max_pos := lbl.info.lbl_pos; ()))
  158.           pat_expr_list
  159.     | _ -> () in
  160.   do_list
  161.     (function (pat::patl, act) -> max_size pat
  162.             | _ -> fatal_error "divide_record_matching")
  163.     casel;
  164.   let rec divide_rec = function
  165.       (Pat(Zaliaspat(pat,v),_) :: patl, action) :: rest ->
  166.         divide_rec ((pat::patl, action) :: rest)
  167.     | (Pat(Zconstraintpat(pat,ty),_) :: patl, action) :: rest ->
  168.         divide_rec ((pat::patl, action) :: rest)
  169.     | (Pat(Zorpat(pat1, pat2),_) :: patl, action) :: rest ->
  170.         divide_rec ((pat1::patl, action) :: (pat2::patl, action) :: rest)
  171.     | (Pat(Zrecordpat pat_expr_list,_) :: patl, action) :: rest ->
  172.         divide_rec_cont pat_expr_list patl action rest
  173.     | (Pat((Zwildpat | Zvarpat _),_) :: patl, action) :: rest ->
  174.         divide_rec_cont [] patl action rest
  175.     | [] ->
  176.         Matching([], make_path (succ !max_pos) pathl)
  177.     | _ ->
  178.         fatal_error "divide_record_matching"
  179.   and divide_rec_cont pat_expr_list patl action rest =
  180.     let v = make_vect (succ !max_pos) (Pat(Zwildpat, no_location)) in
  181.       do_list (fun (lbl, pat) -> v.(lbl.info.lbl_pos) <- pat) pat_expr_list;
  182.       add_to_match (divide_rec rest) (list_of_vect v @ patl, action)
  183.   in
  184.     divide_rec casel
  185. ;;
  186.  
  187. (* Utilities on pattern-matchings *)
  188.  
  189. let length_of_matching (Matching(casel,_)) = list_length casel
  190. ;;
  191.  
  192. let upper_left_pattern =
  193.   let rec strip = function
  194.       Pat(Zaliaspat(pat,_),_) -> strip pat
  195.     | Pat(Zconstraintpat(pat,_),_) -> strip pat
  196.     | Pat(Zorpat(pat1,pat2),_) -> strip pat1
  197.     | pat -> pat in
  198.   function Matching((pat::_, _) :: _, _) -> strip pat
  199.       |                _                 -> fatal_error "upper_left_pattern"
  200. ;;
  201.  
  202. let get_span_of_constr cstr =
  203.   match cstr.info.cs_tag with
  204.     ConstrExtensible _      -> 0       (* Meaningless ... *)
  205.   | ConstrRegular(tag,span) -> span
  206. ;;
  207.  
  208. let get_span_of_matching matching =
  209.   match upper_left_pattern matching with
  210.       Pat(Zconstruct0pat(c), _)   -> get_span_of_constr c
  211.     | Pat(Zconstruct1pat(c,_), _) -> get_span_of_constr c
  212.     | _ -> fatal_error "get_span_of_matching"
  213. ;;
  214.  
  215. (* The tri-state booleans. *)
  216.  
  217. type tristate_logic = False | Maybe | True;;
  218.  
  219. let tristate_or = function
  220.     (True, _)     -> True
  221.   | (_, True)     -> True
  222.   | (False,False) -> False
  223.   |      _        -> Maybe
  224. ;;
  225.  
  226. (* The main compilation function.
  227.    Input: a pattern-matching,
  228.    Output: a lambda term, a "partial" flag, a list of used cases. *)
  229.  
  230. let rec conquer_matching =
  231.   let rec conquer_divided_matching = function
  232.     [] ->
  233.       [], False, []
  234.   | (key, matchref) :: rest ->
  235.       let lambda1, partial1, used1 = conquer_matching !matchref
  236.       and list2,   partial2, used2 = conquer_divided_matching rest in
  237.         (key, lambda1) :: list2,
  238.         tristate_or(partial1,partial2),
  239.         used1 @ used2
  240.   in function
  241.     Matching([], _) ->
  242.       Lstaticfail, True, []
  243.   | Matching(([], action) :: rest, _) ->
  244.       action, False, [action]
  245.   | Matching(_, (path :: _)) as matching ->
  246.      (match upper_left_pattern matching with
  247.         Pat((Zwildpat | Zvarpat _), _) ->
  248.           let vars, rest = divide_var_matching matching in
  249.           let lambda1, partial1, used1 = conquer_matching vars
  250.           and lambda2, partial2, used2 = conquer_matching rest in
  251.             if partial1 == False then
  252.               lambda1, False, used1
  253.             else
  254.           Lstatichandle(lambda1, lambda2),
  255.               (if partial2 == False then False else Maybe),
  256.               used1 @ used2
  257.       | Pat(Ztuplepat patl, _) ->
  258.           conquer_matching (divide_tuple_matching (list_length patl) matching)
  259.       | Pat((Zconstruct0pat(_) | Zconstruct1pat(_,_)),_) ->
  260.           let constrs, vars = divide_construct_matching matching in
  261.           let switchlst, partial1, used1 = conquer_divided_matching constrs
  262.           and lambda,    partial2, used2 = conquer_matching vars in
  263.           let span = get_span_of_matching matching
  264.           and num_cstr = list_length constrs in
  265.             if num_cstr == span & partial1 == False then
  266.               Lswitch(span, path, switchlst), False, used1
  267.             else
  268.               Lstatichandle(Lswitch(span, path, switchlst), lambda),
  269.               (if partial2 == False then False
  270.                else if num_cstr < span & partial2 == True then True
  271.                else Maybe),
  272.               used1 @ used2
  273.       | Pat(Zconstantpat _,_) ->
  274.           let constants, vars = divide_constant_matching matching in
  275.             let condlist1, _, used1 = conquer_divided_matching constants
  276.             and lambda2, partial2, used2 = conquer_matching vars in
  277.               Lstatichandle(Lcond(path, condlist1), lambda2),
  278.               partial2,
  279.               used1 @ used2
  280.       | Pat(Zrecordpat _,_) ->
  281.           conquer_matching (divide_record_matching matching)
  282.       | _ ->
  283.           fatal_error "conquer_matching 2")
  284.   | _ -> fatal_error "conquer_matching 1"
  285. ;;
  286.  
  287. let make_initial_matching = function
  288.     [] ->
  289.       fatal_error "make_initial_matching: empty"
  290.   | (patl, _) :: _ as casel ->
  291.       let rec make_path n =
  292.         if n <= 0 then [] else Lvar(n-1) :: make_path(n-1)
  293.       in
  294.         Matching(casel, make_path(list_length patl))
  295. ;;
  296.  
  297. (* The entry point *)
  298.  
  299. let translate_matching failure_code loc casel =
  300.   let casel' =
  301.     map (fun (patl,l) -> (patl, share_lambda l)) casel in
  302.   let (lambda, partial, used) =
  303.     conquer_matching (make_initial_matching casel') in
  304.   if not for_all (fun (_, act) -> memq act used) casel' then begin
  305.     prerr_location loc;
  306.     prerr_begline " Warning: some cases are unused in this matching.";
  307.     prerr_endline2 ""
  308.   end;
  309.   match partial with
  310.       False -> lambda
  311.     |   _   -> Lstatichandle(lambda, failure_code partial)
  312. ;;
  313.